# csv.pl
use strict;
use warnings;

#require Text::CSV_PP;
require Text::CSV;
#TODO: consider using Text::CSV::Unicode to gracefully accept wide characters in input string

my $FALSE = 0;
my $TRUE  = 1;


#FIXME: Error reporting back to caller is unusable in a REST error response or UI at the moment - contains Perl jargon.

sub csv_parse_string {
    #
    #   ARRAYREF csv_parse_string(STRING $csv_string)
    #
    #   Returns an array of row arrays or throws error if invalid csv
    #
    my ($csv_string) = @_;

    # normalise line ends
    $csv_string =~ s/\r\n|\n\r|\r/\n/gxsm;

    # read csv file and parse each line

    my $saveslash = $/; #preserve slash
    $/ = "\n";
        
#    my $csv = Text::CSV_PP->new ({
    my $csv = Text::CSV->new ({
         quote_char          => '"',
         escape_char         => '"',
         sep_char            => ',',
         eol                 => $/,     #default was $\,
         always_quote        => 0,
         binary              => 1,      #allow non-ascii and newlines
         keep_meta_info      => 0,
         allow_loose_quotes  => 0,
         allow_loose_escapes => 0,
         allow_whitespace    => 1,      #ignore spaces around sep_char
         blank_is_undef      => 0,
         empty_is_undef      => 0,
         verbatim            => 0,
         auto_diag           => 0,
    }) or die "Cannot use CSV: ".Text::CSV->error_diag ();
    my @rows = ();
    my $fh;
    open($fh, '<', \$csv_string) or die "$!";
    $! = undef; #suppress 'No such file or directory' error on perl open attempts
    while (my $row = $csv->getline($fh)) {
        if (defined $row && scalar(@$row) > 0 && !(scalar(@$row) == 1 && $row->[0] eq '')) {
            push(@rows, $row);
        }
    }
    $csv->eof or $csv->error_diag();
    close $fh;

    $/ = $saveslash;  #restore slash

    if (scalar(@rows) == 0) {
        die "The CSV data is not in expected format";
    }

    return \@rows;
}


#
#   Serialise a Perl variable as CSV (auto-creating columns as required)
#


sub serialise_csv {
    #
    #   STRING serialise_csv($value[, HASHREF $options])
    #
    #   Returns a csv representation of Perl variable $value.
    #
    #   Options:
    #       'schema'       whether to include schema (i.e. header) row. Default = $FALSE
    #       'separator'    {comma|tab|colon|space}. Default = comma
    #       'subseparator' {comma|tab|colon|space}. Default = space
    #       'quote'        {single|double|none}. Default = double
    #       'canonical'    sorts hashes on their keys to ensure canonical order. Default = $TRUE
    #
    my ($value, $options) = @_;

    if (!defined $options || ref($options) ne 'HASH') {
        $options = {};
    }
    
    $options->{'schema'} = (defined $options->{'schema'} && $options->{'schema'} eq "$TRUE") ? $TRUE : $FALSE;
    $options->{'canonical'} = (defined $options->{'canonical'} && $options->{'canonical'} eq "$FALSE") ? $FALSE : $TRUE;
    
    my $separators = { 'comma' => ',', 'tab' => "\t", 'colon' => ':', 'semicolon' => ';', 'space' => ' ' };
    if (!defined $options->{'separator'} || !exists $separators->{$options->{'separator'}}) {
         $options->{'separator'} = 'comma';
    }
    if (!defined $options->{'subseparator'} || !exists $separators->{$options->{'subseparator'}}) {
         $options->{'subseparator'} = 'space';
    }

    my $quotes = { 'single' => '\'', 'double' => '"', 'none' => '' };
    if (!defined $options->{'quote'} || !exists $quotes->{$options->{'quote'}}) {
         $options->{'quote'} = 'double';
    }

    # we overload the options hash to also carry around state information
    $options->{'_depth'}   = 0;
#    $options->{'_root_depth'} = undef;
    $options->{'_newline_str'}   = "\n";
    $options->{'_separator_str'} = $separators->{$options->{'separator'}};
    $options->{'_subseparator_str'} = $separators->{$options->{'subseparator'}};
    $options->{'_quote_str'} = $quotes->{$options->{'quote'}};

#    my $header = ($options->{'schema'}) ?  'headers...' . $options->{'_newline_str'} : '';
##FIXME: following header inference is not very useful as only handles top level, which is often single the key "item".
    my $header = '';
    if ($options->{'schema'}) {
        my @h = ();
        if (ref($value) eq 'HASH') {
            my @key = keys(%$value);
            for my $k (@key) {
                $k =~ s/\"/\"\"/gxsm;
                $k =~ s/[\n\r]/ /gxsm;
                push(@h, "\"$k\"");
            }
        }
        elsif (ref($value) eq 'ARRAY') {
            for(my $i=1; $i <= scalar(@$value); $i++) {
                push(@h, "\"value$i\"");
            }
        }
        else {
            push(@h, '"value"');
        }
        $header = join($options->{'_separator_str'}, @h);
        $header .= $options->{'_newline_str'};
    }

    if (defined $value && (ref($value) eq 'HASH' || ref($value) eq 'ARRAY' || $value ne '')) {
        return $header . serialise_csv_value($value, $options);
    }
    return '';
}

sub serialise_csv_value {
    #
    #   STRING serialise_csv_value($value, $options)
    #
    #   Returns a prolog csvs representation of $value.
    #
    my ($value, $options) = @_;
    if (!defined $value) {
        return '';
    }
    elsif (ref($value) eq 'HASH') {
        return serialise_csv_hash($value, $options);
    }
    elsif (ref($value) eq 'ARRAY') {
        return serialise_csv_array($value, $options);
    }
    elsif ($value ne '') {
        return _csv_quote($value, $options);
    }
    return '';
}

sub serialise_csv_hash {
    my ($hash_ref, $options) = @_;
    my @keys = keys %$hash_ref;
    if ($options->{'canonical'}) {
        @keys = sort @keys;
    }
    my @csvs = ();
    $options->{'_depth'}++;
    my $overdepth = (defined $options->{'_root_depth'} && $options->{'_depth'} > $options->{'_root_depth'}) ? $TRUE : $FALSE;
    for my $key (@keys) {
        if ($overdepth) {
            push(@csvs, _csv_quote($key, $options));
        }
        push(@csvs, serialise_csv_value($hash_ref->{$key}, $options));
    }
    my $outdepth = ($options->{'_depth'} == $options->{'_root_depth'}) ? $TRUE : $FALSE;
    my $nl = ($outdepth ? $options->{'_newline_str'} : '');
    my $sep = ($outdepth ? $options->{'_separator_str'} : '');
    $options->{'_depth'}--;
    my $str = join($sep, @csvs);
    if ($options->{'_depth'} == $options->{'_root_depth'}) {
        # remove trailing subseparator from concatenated subfields and then quote all as one string
        $str = substr $str, 0, -length($options->{'_subseparator_str'});
        return $options->{'_quote_str'} . $str . $options->{'_quote_str'};
    }
    return $str . $nl;
}

sub serialise_csv_array {
    my ($array_ref, $options) = @_;
    my @csvs = ();
    $options->{'_depth'}++;
    for my $value (@$array_ref) {
        push(@csvs, serialise_csv_value($value, $options));
    }
    my $nl = ($options->{'_depth'} == $options->{'_root_depth'} ? $options->{'_newline_str'} : '');
    my $sep = ($options->{'_depth'} == $options->{'_root_depth'} ? $options->{'_separator_str'} : '');
    $options->{'_depth'}--;
    my $str = join($sep, @csvs);
    if ($options->{'_depth'} == $options->{'_root_depth'}) {
        # remove trailing subseparator from concatenated subfields and then quote all as one string
        $str = substr $str, 0, -length($options->{'_subseparator_str'});
        return $options->{'_quote_str'} . $str . $options->{'_quote_str'};
    }
    return $str . $nl;
}

sub _csv_quote {
    my ($str, $options) = @_;
    if (!exists $options->{'_root_depth'}) {
        $options->{'_root_depth'} = $options->{'_depth'};
    }
    my $quote = $options->{'_quote_str'};
    $str =~ s/$quote/$quote$quote/gsmx;
    if ($options->{'_depth'} != $options->{'_root_depth'}) {
        return $str . $options->{'_subseparator_str'};
    }
#    if ($str !~ m{^[a-z_][a-zA-Z0-9_]*$|^[+-]?[0-9]+(?:\.[0-9]*)?(?:e[+-][0-9]+)?$}xs) {
    if ($str !~ m{^[+-]?[0-9]+(?:\.[0-9]*)?(?:e[+-][0-9]+)?$}xs) {
        $str = $quote . $str . $quote;
    }
    return $str;
}


1;